home *** CD-ROM | disk | FTP | other *** search
/ User's Choice Windows CD / User's Choice Windows CD (CMS Software)(1993).iso / utility3 / sycolor.zip / SYSCOLOR.PAS < prev    next >
Pascal/Delphi Source File  |  1991-02-27  |  16KB  |  574 lines
  1. { syscolor.pas -- Set System Colors (c) 1991 by Tom Swan.}
  2.  
  3. {$R syscolor.res }
  4.  
  5. program SysColor;
  6.  
  7. uses WinTypes, WinProcs, WObjects, Strings;
  8.  
  9. const
  10.  
  11.   app_Name  = 'SysColor';       { Application name }
  12.   ini_FName = 'SYSCOLOR.INI';   { .INI file name }
  13.  
  14.   id_Menu      = 100;           { Menu resource ID }
  15.   id_Icon      = 200;           { Icon resource ID }
  16.   cm_About     = 101;           { Menu:About command resource ID }
  17.   cm_Quit      = 102;           { Menu:Exit command resource ID }
  18.  
  19.   id_SBarRed   = 100;           { Window control IDs }
  20.   id_SBarGrn   = 101;
  21.   id_SBarBlu   = 102;
  22.   id_STxtRed   = 103;
  23.   id_STxtGrn   = 104;
  24.   id_STxtBlu   = 105;
  25.   id_SetBtn    = 106;
  26.   id_ResetBtn  = 107;
  27.   id_SaveBtn   = 108;
  28.   id_QuitBtn   = 109;
  29.  
  30.   RedMask = $000000FF;          { Color value extraction masks }
  31.   GrnMask = $0000FF00;
  32.   BluMask = $00FF0000;
  33.  
  34.   nonStop: Boolean = false;     { Use switches: -s = false; -n = true }
  35.  
  36.   SysColorName: Array[0 .. color_EndColors] of PChar = (
  37.      'Scroll Bar',
  38.      'Background',
  39.      'Active Caption',
  40.      'Inactive Caption',
  41.      'Menu',
  42.      'Window',
  43.      'Window Frame',
  44.      'Menu Text',
  45.      'Window Text',
  46.      'Caption Text',
  47.      'Active Border',
  48.      'Inactive Border',
  49.      'App Work Space',
  50.      'Highlight',
  51.      'Highlight Text',
  52.      'Button Face',
  53.      'Button Shadow',
  54.      'Gray Text',
  55.      'Button Text'
  56.   );
  57.  
  58. type
  59.  
  60.   SCApplication = object(TApplication)
  61.     constructor Init(AName: PChar);
  62.     procedure InitMainWindow; virtual;
  63.   end;
  64.  
  65.   PSCWindow = ^SCWindow;
  66.   SCWindow = object(TWindow)
  67.  
  68.  {- SCWindow data fields }
  69.     Dc: Hdc;
  70.     ButtonDown, Changed: Boolean;
  71.     LineX1, LineY1, LineX2, LineY2: Integer;
  72.     ArrowCursor, CrossHairCursor: HCursor;
  73.     RedColor, GrnColor, BluColor: Byte;
  74.     SBarRed, SBarGrn, SBarBlu: PScrollBar;
  75.     STxtRed, STxtGrn, STxtBlu: PStatic;
  76.     SampleRect: TRect;
  77.     SampleColor: TColorRef;
  78.     DraggingOrigin: Integer;
  79.  
  80.  {- SCWindow inherited methods }
  81.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  82.     function CanClose: Boolean; virtual;
  83.     procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  84.     procedure SetupWindow; virtual;
  85.     procedure WMLButtonDown(var Msg: TMessage);
  86.       virtual wm_First + wm_LButtonDown;
  87.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  88.  
  89.  {- SCWindow new methods }
  90.     function InsideColorRect(X, Y: Integer; var Index: Integer): Boolean;
  91.     procedure ResetSystemColors;
  92.     procedure SynchronizeScrollBars;
  93.     procedure DrawRubberband;
  94.     procedure CMAbout(var Msg: TMessage); virtual cm_First + cm_About;
  95.     procedure CMQuit(var Msg: TMessage); virtual cm_First + cm_Quit;
  96.     procedure WMLButtonUp(var Msg: TMessage); virtual wm_First + wm_LButtonUp;
  97.     procedure WMMouseMove(var Msg: TMessage); virtual wm_First + wm_MouseMove;
  98.     procedure SBarRedEvent(var Msg: TMessage); virtual id_First + id_SBarRed;
  99.     procedure SBarGrnEvent(var Msg: TMessage); virtual id_First + id_SBarGrn;
  100.     procedure SBarBluEvent(var Msg: TMessage); virtual id_First + id_SBarBlu;
  101.     procedure SetBtnEvent(var Msg: TMessage); virtual id_First + id_SetBtn;
  102.     procedure ResetBtnEvent(var Msg: TMessage); virtual id_First + id_ResetBtn;
  103.     procedure SaveBtnEvent(var Msg: TMessage); virtual id_First + id_SaveBtn;
  104.     procedure QuitBtnEvent(var Msg: TMessage); virtual id_First + id_QuitBtn;
  105.   end;
  106.  
  107.   SysColorRec = record
  108.     OriginalColor: LongInt;   { Color on starting program }
  109.     CurrentColor: LongInt;    { New color selected by user }
  110.     SCRect: TRect;            { Location of system-color rectangle }
  111.   end;
  112.  
  113. var
  114.  
  115.   SysColorArray: Array[0 .. color_EndColors] of SysColorRec;
  116.  
  117.  
  118. {----- Common routines -----}
  119.  
  120. {- Convert integer N to C char array. If Max > 0, pad with leading 0s. }
  121. procedure Int2Str(N, Max: Integer; C: PChar);
  122. var
  123.   S: String[6];
  124. begin
  125.   Str(N, S);
  126.   while Length(S) < Max do S := '0' + S;
  127.   StrPCopy(C, S)
  128. end;
  129.  
  130. {- Prepare global SysColorArray with current color values }
  131. procedure InitSysColorArray;
  132. var
  133.   I: Integer;
  134. begin
  135.   for I := 0 to color_EndColors do with SysColorArray[I] do
  136.   begin
  137.     OriginalColor := GetSysColor(I);
  138.     CurrentColor := OriginalColor;
  139.     with SCRect do
  140.     begin
  141.       Left := 500;
  142.       Top := 20 + (I * 20);
  143.       Right := Left + 100;
  144.       Bottom := Top + 15
  145.     end
  146.   end
  147. end;
  148.  
  149. {- Change system colors to values in SysColorArray }
  150. procedure ChangeSystemColors;
  151. var
  152.   I: Integer;
  153.   InxArray: Array[0 .. color_EndColors] of Integer;
  154.   ClrArray: Array[0 .. color_EndColors] of TColorRef;
  155. begin
  156.   for I := 0 to color_EndColors do
  157.   begin
  158.     InxArray[I] := I;
  159.     ClrArray[I] := SysColorArray[I].CurrentColor
  160.   end;
  161.   SetSysColors(color_EndColors + 1, InxArray[0], ClrArray[0])
  162. end;
  163.  
  164. {- Save colors to SYSCOLOR.INI in Windows directory }
  165. function SaveSettings: Boolean;
  166. var
  167.   I: Integer;
  168.   S: String[12];
  169.   NewValue: array[0 .. 12] of Char;
  170. begin
  171.   SaveSettings := true;  { Think positively! }
  172.   for I := 0 to color_EndColors do with SysColorArray[I] do
  173.   begin
  174.     Str(CurrentColor, S);
  175.     StrPCopy(NewValue, S);
  176.     if not WritePrivateProfileString(app_Name, SysColorName[I],
  177.       NewValue, ini_FName) then
  178.     begin
  179.       SaveSettings := false;
  180.       Exit
  181.     end
  182.   end
  183. end;
  184.  
  185. {- Load colors from SYSCOLOR.INI if present }
  186. procedure LoadSettings;
  187. var
  188.   I, Err: Integer;
  189.   S: String[12];
  190.   DefaultValue, NewValue: array[0 .. 12] of Char;
  191. begin
  192.   for I := 0 to color_EndColors do with SysColorArray[I] do
  193.   begin
  194.     Str(CurrentColor, S);
  195.     StrPCopy(DefaultValue, S);
  196.     GetPrivateProfileString(app_Name, SysColorName[I],
  197.       DefaultValue, NewValue, sizeof(NewValue), ini_FName);
  198.     S := StrPas(NewValue);
  199.     Val(S, CurrentColor, Err);
  200.     if Err <> 0 then CurrentColor := OriginalColor
  201.   end;
  202.   GetPrivateProfileString(app_Name, 'nonstop',
  203.     'false', NewValue, sizeof(NewValue), ini_FName);
  204.   if StrComp('false', NewValue) <> 0
  205.     then nonStop := true
  206. end;
  207.  
  208. {- Get command-line switches }
  209. procedure GetSwitches;
  210. var
  211.   I: Integer;
  212.   S: String[128];
  213.   C: Char;
  214. begin
  215.   for I := 1 to ParamCount do
  216.   begin
  217.     S := ParamStr(I);
  218.     C := upcase(S[1]);
  219.     if (Length(S) > 1) and ((C = '-') or (C = '/')) then
  220.     case upcase(S[2]) of
  221.       'N' : nonStop := true;
  222.       'S' : nonStop := false
  223.     end
  224.   end
  225. end;
  226.  
  227.  
  228. {----- SCApplication methods -----}
  229.  
  230. {- Construct SCApplication object }
  231. constructor SCApplication.Init(AName: PChar);
  232. begin
  233.   TApplication.Init(AName);
  234.   InitSysColorArray;          { Initialize colors }
  235.   LoadSettings;               { Load .INI settings if present }
  236.   GetSwitches;                { Get command-line switches }
  237.   if nonStop then
  238.   begin
  239.     ChangeSystemColors;       { Change colors to .INI settings }
  240.     PostQuitMessage(0);       { Exit without stopping }
  241.   end
  242. end;
  243.  
  244. {- Initialize application's window }
  245. procedure SCApplication.InitMainWindow;
  246. begin
  247.   MainWindow := New(PSCWindow, Init(nil, 'Set System Colors'))
  248. end;
  249.  
  250.  
  251. {----- SCWindow methods -----}
  252.  
  253. {- Construct SCWindow object and instantiate child windows }
  254. constructor SCWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  255. var
  256.   AStat: PStatic;
  257.   ABtn: PButton;
  258. begin
  259.   TWindow.Init(AParent, ATitle);
  260.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  261.   with Attr do
  262.   begin
  263.     X := 10; Y := 10; H := 460; W := 615
  264.   end;
  265.   ButtonDown := false;
  266.   Changed := false;
  267.   ArrowCursor := LoadCursor(0, idc_Arrow);
  268.   CrossHairCursor := LoadCursor(0, idc_Cross);
  269.   RedColor := 0;
  270.   GrnColor := 0;
  271.   BluColor := 0;
  272.   SampleColor := 0;
  273.   with SampleRect do
  274.   begin
  275.     Left := 200; Top := 150; Right := 300; Bottom := 230;
  276.   end;
  277.   SBarRed := New(PScrollBar, Init(@Self, id_SBarRed, 50,  20, 250, 0, True));
  278.   SBarGrn := New(PScrollBar, Init(@Self, id_SBarGrn, 50,  60, 250, 0, True));
  279.   SBarBlu := New(PScrollBar, Init(@Self, id_SBarBlu, 50, 100, 250, 0, True));
  280.   AStat   := New(PStatic, Init(@Self, 0, 'Red',   5,  20, 40, 20, 3));
  281.   AStat   := New(PStatic, Init(@Self, 0, 'Green', 5,  60, 40, 20, 5));
  282.   AStat   := New(PStatic, Init(@Self, 0, 'Blue',  5, 100, 40, 20, 4));
  283.   AStat   := New(PStatic, Init(@Self, 0, 'Color', 235, 240, 40, 20, 5));
  284.   STxtRed := New(PStatic, Init(@Self, id_STxtRed, '000', 310,  20, 40, 20, 3));
  285.   STxtGrn := New(PStatic, Init(@Self, id_STxtGrn, '000', 310,  60, 40, 20, 3));
  286.   STxtBlu := New(PStatic, Init(@Self, id_STxtBlu, '000', 310, 100, 40, 20, 3));
  287.   ABtn    := New(PButton, Init(@Self, id_SetBtn,
  288.     'Set',   50, 150, 80, 40, false));
  289.   ABtn    := New(PButton, Init(@Self, id_ResetBtn,
  290.     'Reset', 50, 210, 80, 40, false));
  291.   ABtn    := New(PButton, Init(@Self, id_SaveBtn,
  292.     'Save',  50, 270, 80, 40, false));
  293.   ABtn    := New(PButton, Init(@Self, id_QuitBtn,
  294.     'Quit',  50, 330, 80, 40, true))
  295. end;
  296.  
  297. {- Return true if window may close }
  298. function SCWindow.CanClose: Boolean;
  299. var
  300.   Answer: Integer;
  301. begin
  302.   CanClose := true;
  303.   if Changed then
  304.   begin
  305.     Answer := MessageBox(HWindow, 'Save colors before quitting?',
  306.       'Please answer', mb_YesNoCancel or mb_IconQuestion);
  307.     if Answer = idYes then
  308.       CanClose := SaveSettings
  309.     else if Answer = idCancel then
  310.       CanClose := false
  311.   end
  312. end;
  313.  
  314. {- Reset system colors to values saved at start of program }
  315. procedure SCWindow.ResetSystemColors;
  316. var
  317.   I: Integer;
  318. begin
  319.   for I := 0 to color_EndColors do with SysColorArray[I] do
  320.     CurrentColor := OriginalColor;
  321.   Changed := false
  322. end;
  323.  
  324. {- Modify window class to use custom icon }
  325. procedure SCWindow.GetWindowClass(var AWndClass: TWndClass);
  326. begin
  327.   TWindow.GetWindowClass(AWndClass);
  328.   AWndClass.hIcon := LoadIcon(HInstance, PChar(id_Icon))
  329. end;
  330.  
  331. {- Perform setup duties for a newly created SCWindow object. }
  332. procedure SCWindow.SetupWindow;
  333. begin
  334.   TWindow.SetupWindow;
  335.   SBarRed^.SetRange(0, 255);
  336.   SBarGrn^.SetRange(0, 255);
  337.   SBarBlu^.SetRange(0, 255)
  338. end;
  339.  
  340. {- Adjust scroll bars to match SampleColor }
  341. procedure SCWindow.SynchronizeScrollBars;
  342. var
  343.   DummyMsg: TMessage;
  344. begin
  345.   SBarRed^.SetPosition(SampleColor and RedMask);
  346.   SBarGrn^.SetPosition((SampleColor and GrnMask) shr 8);
  347.   SBarBlu^.SetPosition((SampleColor and BluMask) shr 16);
  348.   SBarRedEvent(DummyMsg);
  349.   SBarGrnEvent(DummyMsg);
  350.   SBarBluEvent(DummyMsg)
  351. end;
  352.  
  353. {- Display "About program" dialog box }
  354. procedure SCWindow.CMAbout(var Msg: TMessage);
  355. var
  356.   Dialog: TDialog;
  357. begin
  358.   Dialog.Init(@Self, 'About');
  359.   Dialog.Execute;
  360.   Dialog.Done
  361. end;
  362.  
  363. {- Execute Menu:Exit command }
  364. procedure SCWindow.CMQuit(var Msg: TMessage);
  365. begin
  366.   PostQuitMessage(0)
  367. end;
  368.  
  369. {- Draw rubberband connecting line while dragging colors }
  370. procedure SCWindow.DrawRubberband;
  371. begin
  372.   MoveTo(Dc, LineX1, LineY1);
  373.   LineTo(Dc, LineX2, LineY2)
  374. end;
  375.  
  376. {- Return true if point X, Y is inside a color rectangle }
  377. function SCWindow.InsideColorRect(X, Y: Integer; var Index: Integer): Boolean;
  378. var
  379.   CursorLocation: TPoint;
  380.   I: Integer;
  381. begin
  382.   CursorLocation.X := X;
  383.   CursorLocation.Y := Y;
  384.   InsideColorRect := true;
  385.   if PtInRect(SampleRect, CursorLocation) then
  386.   begin
  387.     Index := -1;      { Inside sample color box }
  388.     Exit
  389.   end else
  390.   for I := 0 to color_EndColors do
  391.     if PtInRect(SysColorArray[I].SCRect, CursorLocation) then
  392.     begin
  393.       Index := I;     { Inside a system color rectangle }
  394.       Exit
  395.     end;
  396.   InsideColorRect := false
  397. end;
  398.  
  399. {- Handle left-button down event }
  400. procedure SCWindow.WMLButtonDown(var Msg: TMessage);
  401. begin
  402.   if not ButtonDown then with Msg do
  403.   if InsideColorRect(LParamLo, LParamHi, DraggingOrigin) then
  404.   begin
  405.     Dc := GetDC(HWindow);
  406.     LineX1 := LParamLo;
  407.     LineY1 := LParamHi;
  408.     LineX2 := LineX1;
  409.     LineY2 := LineY1;
  410.     SetROP2(Dc, r2_Not);
  411.     DrawRubberband;
  412.     ButtonDown := true;
  413.     SetCursor(CrossHairCursor);
  414.     SetCapture(HWindow);
  415.     if DraggingOrigin >= 0 then {- Clicked in a system color rectangle }
  416.     begin
  417.       SampleColor := SysColorArray[DraggingOrigin].CurrentColor;
  418.       SynchronizeScrollBars
  419.     end
  420.   end
  421. end;
  422.  
  423. {- Handle left-button up event }
  424. procedure SCWindow.WMLButtonUp(var Msg: TMessage);
  425. var
  426.   Index: Integer;
  427.   NewColor: TColorRef;
  428. begin
  429.   if ButtonDown then with Msg do
  430.   begin
  431.     if InsideColorRect(LParamLo, LParamHi, Index) then
  432.     if (Index <> DraggingOrigin) and (Index >= 0) then
  433.     begin
  434.       Changed := true;
  435.       if DraggingOrigin >= 0
  436.         then NewColor := SysColorArray[DraggingOrigin].CurrentColor
  437.         else NewColor := SampleColor;
  438.       SysColorArray[Index].CurrentColor := NewColor;
  439.       InvalidateRect(HWindow, nil, False)
  440.     end;
  441.     DrawRubberband;         { Erase last line }
  442.     SetROP2(Dc, r2_Black);
  443.     ButtonDown := false;
  444.     SetCursor(ArrowCursor);
  445.     ReleaseDC(HWindow, Dc);
  446.     ReleaseCapture
  447.   end
  448. end;
  449.  
  450. {- Handle mouse-move event }
  451. procedure SCWindow.WMMouseMove(var Msg: TMessage);
  452. begin
  453.   if ButtonDown then
  454.   begin
  455.     DrawRubberband;         { Erase old line }
  456.     with Msg do
  457.     begin
  458.       LineX2 := LParamLo;
  459.       LineY2 := LParamHi;
  460.       DrawRubberband        { Draw new line }
  461.     end
  462.   end
  463. end;
  464.  
  465. {- Handle change to red scroll bar position }
  466. procedure SCWindow.SBarRedEvent(var Msg: TMessage);
  467. var
  468.   C: Array[0 .. 3] of Char;
  469. begin
  470.   RedColor := SBarRed^.GetPosition;
  471.   Int2Str(RedColor, 3, C);
  472.   STxtRed^.SetText(C);
  473.   SampleColor := RGB(RedColor, GrnColor, BluColor);
  474.   InvalidateRect(HWindow, @SampleRect, False)
  475. end;
  476.  
  477. {- Handle change to green scroll bar position }
  478. procedure SCWindow.SBarGrnEvent(var Msg: TMessage);
  479. var
  480.   C: Array[0 .. 3] of Char;
  481. begin
  482.   GrnColor := SBarGrn^.GetPosition;
  483.   Int2Str(GrnColor, 3, C);
  484.   STxtGrn^.SetText(C);
  485.   SampleColor := RGB(RedColor, GrnColor, BluColor);
  486.   InvalidateRect(HWindow, @SampleRect, False)
  487. end;
  488.  
  489. {- Handle change to blue scroll bar position }
  490. procedure SCWindow.SBarBluEvent(var Msg: TMessage);
  491. var
  492.   C: Array[0 .. 3] of Char;
  493. begin
  494.   BluColor := SBarBlu^.GetPosition;
  495.   Int2Str(BluColor, 3, C);
  496.   STxtBlu^.SetText(C);
  497.   SampleColor := RGB(RedColor, GrnColor, BluColor);
  498.   InvalidateRect(HWindow, @SampleRect, False)
  499. end;
  500.  
  501. procedure SCWindow.SetBtnEvent(var Msg: TMessage);
  502. begin
  503.   ChangeSystemColors
  504. end;
  505.  
  506. procedure SCWindow.ResetBtnEvent(var Msg: TMessage);
  507. begin
  508.   ResetSystemColors;
  509.   ChangeSystemColors
  510. end;
  511.  
  512. procedure SCWindow.SaveBtnEvent(var Msg: TMessage);
  513. begin
  514.   if SaveSettings then Changed := false
  515. end;
  516.  
  517. procedure SCWindow.QuitBtnEvent(var Msg: TMessage);
  518. begin
  519.   PostQuitMessage(0)
  520. end;
  521.  
  522. procedure SCWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  523. var
  524.   OldBrush, TheBrush: HBrush;
  525.   I: Integer;
  526.  
  527.   procedure ShowSysColor(I: Integer);
  528.   var
  529.     SysColorBrush : HBrush;
  530.     OldBrush: HBrush;
  531.     SCName : PChar;
  532.   begin
  533.     with SysColorArray[I], SCRect do
  534.     begin
  535.       SysColorBrush := CreateSolidBrush(CurrentColor);
  536.       OldBrush := SelectObject(PaintDC, SysColorBrush);
  537.       Rectangle(PaintDC, Left, Top, Right, Bottom);
  538.       SelectObject(PaintDC, OldBrush);
  539.       DeleteObject(SysColorBrush);
  540.       SCName := SysColorName[I];
  541.       TextOut(PaintDC, Left - 125, Top, SCName, StrLen(SCName))
  542.     end
  543.   end;
  544.  
  545. begin
  546.   TheBrush := CreateSolidBrush(SampleColor);
  547.   OldBrush := SelectObject(PaintDC, TheBrush);
  548.   with SampleRect do Rectangle(PaintDC, Left, Top, Right, Bottom);
  549.   SelectObject(PaintDC, OldBrush);
  550.   DeleteObject(TheBrush);
  551.   for I := 0 to color_EndColors do
  552.     ShowSysColor(I)
  553. end;
  554.  
  555. var
  556.  
  557.   SCApp: SCApplication;
  558.  
  559. begin
  560.   SCApp.Init(app_Name);
  561.   SCApp.Run;
  562.   SCApp.Done
  563. end.
  564.  
  565.  
  566. { --------------------------------------------------------------
  567.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  568.   Revision 1.00    Date: 2/1/1991
  569.   Revision 1.01    Date: 2/27/1991
  570.   1. Changed all cm_Exit constants to cm_Quit
  571.   2. Changed all CMExit procedure names to CMQuit
  572.   3. Added length argument to all TStatic object inits
  573.   ------------------------------------------------------------- }
  574.